Shareware Grab Bag

home *** CD-ROM | disk | FTP | other *** search

/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / white.arc / MVPDOSV3.4TH < prev next >

Wrap

Text File | 1986-11-07 | 17.6 KB | 546 lines

\ <PAGEW> clear video utility 13Dec83RSW FORTH DEFINITIONS DECIMAL ( <PAGEW> -- SETS 80 COLUMN B&W MODE FOR COLOR GRAPHICS ADPTR ) : <PAGEW> 2 0 0 0 16 INTCALL DROP ; FIND <PAGEW> 'PAGE ! ( update init video vector ) FREEZE : BEEP 7 EMIT ; \ alert operator utility \ MYSELF ASCII BEEP 17Dec83RSW FORTH DEFINITIONS DECIMAL : MYSELF LATEST PFA CFA , ; IMMEDIATE \ recurse do current word : ASCII BL WORD 1+ C@ STATE @ \ convert next char to ASCII IF [COMPILE] LITERAL THEN ; IMMEDIATE : BEEP 7 EMIT ; \ 17Dec83RSW EXIT \ .B CARRAY ARRAY STRING 17Dec83RSW FORTH DEFINITIONS DECIMAL : .B BASE @ DUP ." Now in base " DECIMAL . CR BASE ! ; : CARRAY ( # bytes --- ) ( # --- addr ) CREATE 1+ ALLOT DOES> + ; : ARRAY ( # words --- ) ( # --- addr ) CREATE 1+ 2* ALLOT DOES> SWAP 2* + ; : STRING ( N-MAX --> ) CREATE 1 MAX 255 MIN DUP C, 0 C, ALLOT DOES> 1+ COUNT ; \ FLEN return length of a string 06Nov83RSW DECIMAL : FLEN ( addr --- count ) \ return length of string 255 0 DO DUP I + C@ 0= IF I LEAVE THEN LOOP SWAP DROP ; \ ACCEPT LEN MLEN S! string manipulation stuff 13Dec83RSW FORTH DEFINITIONS DECIMAL : ACCEPT ( string --- ) \ transfer chars from term to string DROP 1- DUP 1- @ OVER 1+ DUP ROT ( addr-1 addr addr n --- ) EXPECT FLEN SWAP C! ; : LEN SWAP DROP ; ( string --- string-current-length ) : MLEN DROP 2- C@ ; ( string --- string-max-length ) : S! ( string1 string2 --- ) \ stores string1 into string2 DROP DUP 2- C@ ROT MIN DUP 3 PICK 1- C! CMOVE ; \ <"> " ILINE NULL$ string manipulation stuff 06Nov83RSW : <"> R@ COUNT DUP 1+ R> + >R ; HEX : " 22 \ push terminator " onto stack STATE @ IF COMPILE <"> WORD C@ 1+ ALLOT ELSE TEXT PAD COUNT THEN ; IMMEDIATE DECIMAL 82 STRING ILINE 0 STRING NULL$ \ MID$ RIGHT$ LEFT$ VAL CHR$ ASC SUB! 06Nov83RSW DECIMAL : MID$ >R OVER MIN 1 MAX 1- SWAP OVER - R> MIN >R + R> ; : RIGHT$ OVER 1+ SWAP - 255 MID$ ; : LEFT$ 1 SWAP MID$ ; : VAL >R PAD 1+ R@ CMOVE R@ PAD C! 0 PAD 1+ R> + C! PAD NUMBER ; : CHR$ PAD ! PAD 1 ; : ASC DROP C@ ; : SUB! ROT MIN 0 MAX CMOVE ; \ S= compare two strings for equality 06Nov83RSW : S= ROT OVER = IF ?DUP IF 1 SWAP 0 DO DROP OVER C@ OVER C@ = IF 1+ SWAP 1+ SWAP 1 ELSE 0 LEAVE THEN LOOP ELSE 1 THEN ELSE DROP 0 THEN SWAP DROP SWAP DROP ; \ S< compare two strings for alphabetic order 13Dec83RSW : S< ( str1 str2 --- f ) \ true if str1 lower than str2 ROT OVER MIN SWAP OVER > >R ?DUP IF -1 SWAP 0 DO DROP OVER C@ OVER C@ = IF 1+ SWAP 1+ SWAP -1 ELSE C@ SWAP C@ > LEAVE THEN LOOP DUP 0< IF 2DROP DROP R> ELSE R> DROP THEN ELSE 2DROP R> THEN ; \ S+ STR$ STRING-ARRAY 06Nov83RSW : S+ >R OVER R@ + OVER 2- C@ MIN OVER OVER SWAP 1- C! R> 1+ 255 MID$ SUB! ; : STR$ SWAP OVER DABS <# #S ROT SIGN #> ; : STRING-ARRAY CREATE 0 DO DUP C, 0 C, DUP ALLOT LOOP DOES> DUP C@ 2+ ROT * + 1+ COUNT ; : IN$ ( str1 str2 --- npos ) \ finds position of str1 13Dec83RSW DUP 4 PICK - DUP 0> IF SWAP OVER - IF 0 SWAP 2+ 1 DO DROP 3 PICK C@ OVER C@ = IF 3 PICK 3 PICK 3 PICK OVER S= IF I LEAVE ELSE 1+ 0 THEN ELSE 1+ 0 THEN LOOP ELSE DROP 0 THEN >R 2DROP DROP R> ELSE DROP S= THEN ; \ GET$ INPUT$ GET INPUT operator input of data 13Dec83RSW HEX : GET$ ( n-width --- str ) \ fetch kybd chars into string PAD \ string length limit set by n-width 1+ DUP ROT EXPECT FLEN PAD C! PAD COUNT ; : INPUT$ ( --- str ) \ fetch up 80 char string from kybd 50 GET$ ; : GET ( n-width --- dn ) \ fetch double number from kybd GET$ VAL ; \ inpu field width set by n-width : INPUT ( --- dn ) \ fetch double number from kybd 50 GET ; DECIMAL \ RECLEN FCBLEN DBUFSIZE FCB - DOS file interface 16Nov83RSW FORTH DEFINITIONS DECIMAL 128 CONSTANT RECLEN \ DOS disk file record length 37 CONSTANT FCBLEN \ DOS file control block length RECLEN FCBLEN + CONSTANT DBUFSIZE \ total FCB&data buffer size : FCB ( usage "FCB fcb-name" ) \ builds file control block CREATE HERE DBUFSIZE ERASE DBUFSIZE ALLOT DOES> ; \ DSKADR@ SETDMA FILEOP FILEOP2 - DOS file interface 15Nov83RSW : DSKADR@ ( fcb-addr -- disk-data-addr ) FCBLEN + ; \ fetch address of corresponding data buffer : SETDMA ( fcb-addr -- ) \ set up disk file transfer address 26 SWAP ( function-code fcb-addr -- ) DSKADR@ ( function-code disk-data-addr -- ) SYSCALL DROP ; \ do DOS function & drop status : FILEOP ( fcb-addr dos-function-code -- DOS-file-status ) SWAP SYSCALL 255 AND ; ( normally 0 for no error ) : FILEOP2 FILEOP DUP 0= IF \ do file operation - error? DROP DSKADR@ \ no - return start of data address ELSE SWAP DROP \ yes - return error code THEN ; \ CLOSEF SEARCHF NEXTF KILLF READF WRITEF - DOS file 16Nov83RSW : OPENF ( fcb-addr -- status ) \ open an existing file DUP 15 FILEOP \ do DOS file open SWAP 14 + RECLEN SWAP ! ; \ set record length into fcb : CLOSEF 16 FILEOP ; \ close file after writing : SEARCHF 17 FILEOP ; \ search directory for a file : NEXTF 18 FILEOP ; \ search directory for next file : KILLF 19 FILEOP ; \ wipe out mention of a file : READF ( fcb-addr -- data-addr/error) \ read next file record DUP DUP SETDMA \ set up data transfer address 20 FILEOP2 ; \ read next record. 4 < is an error : WRITEF ( fcb-addr -- data-addr/error) \ write next file record DUP DUP SETDMA \ set up data transfer address 21 FILEOP2 ; \ write next record 3 < is an error \ CREATEF RENAMEF FILEOP3 READFR WRITEFR - DOS file 14Nov83RSW : CREATEF ( fcb-addr -- status) \ create a new flie DUP 22 FILEOP \ do DOS file creation SWAP 14 + RECLEN SWAP ! ; \ set record length into fcb : RENAMEF ( fcb-addr -- status ) \ rename a file 23 FILEOP ; ( NOTE: new name at fcb-addr+17 ) : FILEOP3 OVER 33 + ! DUP DUP SETDMA ; : READFR ( fcb-addr record-number -- data-addr/error ) FILEOP3 \ prepare for random file operation 33 FILEOP2 ; \ read a record randomly : WRITEFR ( fcb-addr record-number -- data-addr/error ) FILEOP3 \ prepare for random file operation 34 FILEOP2 ; \ write a record randomly \ DO-TYPE last part of PREP-FCB - DOS file interface 15Nov83RSW : DO-TYPE DUP C@ ASCII . = IF \ file type specified? SWAP 8 + SWAP 1+ \ yes - fetch it 3 0 DO DUP C@ DUP ASCII ! < IF \ end of file type? DROP LEAVE \ yes - move on ELSE 3 PICK I + C! 1+ \ no - move type char into fcb THEN LOOP THEN DROP 5 + ( fcb-addr+14 -- ) RECLEN SWAP ! ; \ set up record length & exit \ PREP-FCB DOS file interface cont 15Nov83RSW : PREP-FCB ( fcb-addr filename-addr -- ) OVER DUP FCBLEN ERASE 1+ 11 BLANK \ null&blank out fcb&buff DUP 1+ C@ ASCII : = IF \ drive specifier? DUP C@ ASCII @ - \ yes - fetch as binary # 1 MAX 2 MIN 3 PICK C! 2+ \ store only valid range THEN ( fcb-addr filename-addr -- ) SWAP 1+ SWAP 8 0 DO \ move name char into fcb DUP C@ DUP ( fcb-addr+1 filename-addr char char -- ) ASCII . = OVER ASCII ! < OR IF \ name field terminator? DROP LEAVE \ yes - move on ELSE 3 PICK I + C! 1+ \ no - store name char THEN LOOP DO-TYPE ; \ FCTRLZ truncates string at any control-Z 7Nov83RSW FORTH DEFINITIONS DECIMAL 1 STRING EOF 26 CHR$ EOF S! \ define end-of-file string char : FCTRLZ ( addr1 len1 --- ) EOF ( addr1 len1 addr2 len2 --- ) 4 PICK 4 ROLL ( addr1 addr2 len2 addr1 len1 --- ) IN$ ( addr1 npos --- ) ?DUP 0> IF ( addr1 ?npos --- ) \ any EOF's? 1- SWAP 1- ( npos-1 addr1-1 --- ) C! \ yes - truncate length ELSE DROP THEN ; \ FILE1 SEE1 test DOS disk file interface 16Nov83RSW FORTH DEFINITIONS DECIMAL FCB FILE1 RECLEN STRING OBUF : SEE1 \ define & display FILE1 FILE1 CR ." file to display? " INPUT$ DROP PREP-FCB CR FILE1 OPENF 255 = IF ." can't open file " ABORT THEN BEGIN FILE1 READF DUP 3 > WHILE RECLEN OBUF S! OBUF FCTRLZ OBUF TYPE \ process file data REPEAT DROP FILE1 CLOSEF 255 = IF CR ." close error" THEN QUIT ; \ screens to DOS file variables & constants 15Nov83RSW FORTH DEFINITIONS DECIMAL VARIABLE DSKPOS \ char position in disk buffer VARIABLE FEND \ end of DOS file flag VARIABLE CHARPOS \ char position in line buffer 2 STRING CRLF 13 CHR$ CRLF S! 10 CHR$ CRLF S+ \ CR LF string 1 STRING TAB 9 CHR$ TAB S! \ TAB string 8 CONSTANT TABMOD \ TAB modulus VARIABLE SCRLIM \ screen limit storage VARIABLE LINE-COMPRESS \ line compression flag VARIABLE TAB-COMPRESS \ tab compression flag VARIABLE SCRLINE \ screen line # 16 CONSTANT LINE-SCR \ lines per screen 9 STRING SCR-SEP \ screen seperator string NULL$ SCR-SEP S! \ initialize screen seperator string VARIABLE BLKADR \ current block address pointer storage \ PUTLINE puts line into disk buff-scrns to DOS cont. 16Nov83RSW : PUTLINE ILINE LEN 0> IF \ any char in string? 0 CHARPOS ! BEGIN \ yes - doit ILINE DROP CHARPOS @ + C@ \ fetch char from line FILE1 DSKADR@ DSKPOS @ + C! \ store char to dskbuf 1 DSKPOS +! DSKPOS @ RECLEN = IF \ incr dskpos - full? FILE1 WRITEF 3 < IF \ yes-write disk buf CR BEEP ABORT" disk full" THEN \ write error exit 0 DSKPOS ! \ reset disk char pos THEN 1 CHARPOS +! \ bump string char pos CHARPOS @ ILINE LEN = \ loop until char pos = string len UNTIL THEN ; \ COMPRESS spaces out of line buff-scrns to DOS cont. 8Nov83RSW : COMPRESS LINE-COMPRESS @ 0> IF \ compression turned on ? ILINE -TRAILING SWAP 1- C! \ yes - delete trail spaces CRLF ILINE S+ \ add carriage-return linefeed TAB-COMPRESS @ 0> IF \ compress spaces to tabs? 1 DROP \ yes - add tab compress here THEN THEN ; \ WRITE-OPEN screens to DOS continued 15Nov83RSW \ warning - the filename string must end with a null ! : WRITE-OPEN ( filename-str --- ) DROP DUP FILE1 SWAP ( filename-addr fcb filename-addr --- ) PREP-FCB ( filename-addr --- ) \ prepare fcb FILE1 KILLF DROP \ kill any previous file FILE1 SWAP PREP-FCB ( --- ) \ re-prepare fcb FILE1 CREATEF 255 = IF \ open file - error ? BEEP CR ABORT" can't make new file " \ yes - give up THEN 0 DSKPOS ! \ intialize disk buffer offset pointer ; \ FETCH-SCR FETCH-LINE screens to DOS continued 8Nov83RSW : FETCH-SCR \ fetches screen # stored in SCR into a BLOCK SCR @ BLOCK ( blk-addr --- ) BLKADR ! \ intialize block address storage SCR-SEP ILINE S! \ put screen seperator into line buffer PUTLINE \ write screen seperator to disk file 0 SCRLINE ! \ intialize screen line counter 1 SCR +! ; \ update scr # to next screen : FETCH-LINE \ fetches line out of a block into line buffer BLKADR @ C/L ILINE S! \ fetch line into line buffer C/L BLKADR +! \ update buffer address to next line 1 SCRLINE +! ; \ update line # to next line : SCRNS->DOS ( first-scr last-scr filename-str ---) \ 17Dec83RSW WRITE-OPEN SCRLIM ! SCR ! CR \ set up file & scr stuff BEGIN SCR @ . 13 EMIT FETCH-SCR \ get next scr into block BEGIN FETCH-LINE \ get next line from block COMPRESS \ do any line compression PUTLINE \ write line to DOS file SCRLINE @ LINE-SCR = \ till all scr lines done UNTIL SCR @ SCRLIM @ > \ till all scrns done UNTIL EOF ILINE S! PUTLINE \ put ^Z into DOS file FILE1 WRITEF 3 < IF \ write last part of file BEEP CR ABORT" disk full" THEN FILE1 CLOSEF 255 = IF \ update DOS directory BEEP CR ABORT" close error" THEN CR ." screen(s) transfered OK " CR ; \ SEND-SCRNS transfers standard screens to DOS file 8Nov83RSW 15 STRING OFILE$ : SEND-SCRNS CR ." enter 1 to compress lines " INPUT DROP LINE-COMPRESS ! CR ." enter 1 to compress spaces with tabs " INPUT DROP TAB-COMPRESS ! CR ." first screen # ? " INPUT DROP CR ." last screen # ? " INPUT DROP CR ." desired DOS screen filename ? " INPUT$ OFILE$ S! OFILE$ SCRNS->DOS ; \ PROC-CHAR process char into line buffer 19Nov83RSW VARIABLE MAXCHAR 0 MAXCHAR ! : PROC-CHAR ( char --- ) DUP 13 = IF \ carriage return? DROP MAXCHAR @ IF 0 MAXCHAR ! ELSE \ yes-skip if line ful C/L CHARPOS @ - \ # blanks to write ILINE DROP CHARPOS @ + SWAP BLANK \ write blanks C/L CHARPOS ! THEN \ max char counter ELSE DUP 10 = IF DROP \ linefeed? yes - skip ELSE DUP 26 = IF \ end-of-file? 1 FEND ! DROP 13 MYSELF \ yes-set end & recurse a CR ELSE \ no-store char & bump count ILINE DROP CHARPOS @ + C! 1 CHARPOS +! C/L CHARPOS @ = IF \ at max char? 1 MAXCHAR ! THEN \ yes - set flag THEN THEN THEN ; \ GETLINE gets a screen line from DOS file buffer 16Nov83RSW : GETLINE 0 CHARPOS ! \ initialize line char count BEGIN FILE1 DSKADR@ DSKPOS @ + C@ \ fetch file char PROC-CHAR \ put char in line buff 1 DSKPOS +! \ bump disk buff pos DSKPOS @ RECLEN = IF \ finished disk buffer? FILE1 READF 4 < IF \ yes-read more - done 1 FEND ! \ yes - set done flag 13 PROC-CHAR \ finish up line THEN 0 DSKPOS ! \ reset disk buff pos THEN CHARPOS @ C/L = FEND @ OR \ till line or file done UNTIL C/L ILINE DROP 1- C! ; \ set line length \ READ-OPEN DOS to screens continued 19Nov83RSW \ warning - the filename string must end with a null ! : READ-OPEN ( filename-str --- ) DROP FILE1 SWAP ( fcb filename-addr --- ) PREP-FCB ( --- ) \ prepare fcb FILE1 OPENF 255 = IF \ open file - error ? BEEP CR ABORT" can't open file" \ yes - give up THEN FILE1 READF 4 < IF \ get first record - none? BEEP CR ABORT" null length file " \ yes - give up THEN 0 DSKPOS ! \ intialize disk buffer offset pointer 0 MAXCHAR ! ; \ intialize filled line flag \ LINEPUT NEXT-SCR DOS to screens cont. 13Nov83RSW : LINEPUT ( --- ) ILINE DROP BLKADR @ C/L CMOVE \ put line buff in block buff C/L BLKADR +! \ update current block addr ; : NEXT-SCR SCR @ BLOCK ( blk-addr --- ) \ fetch next block DUP BLKADR ! \ intialize block address UPDATE \ mark as modified LINE-SCR C/L * BLANK \ blank out block 1 SCR +! \ point to next screen ; \ DOS->SCRNS DOS file to FORTH screens transfer 11Nov83RSW : DOS->SCRNS ( first-scr filename-str --- ) \ READ-OPEN SCR ! 0 FEND ! \ open DOS file & set variables BEGIN NEXT-SCR \ fetch next screen blk LINE-SCR 0 DO \ write appropiate # lines into scre GETLINE \ fetch line out of file buffer LINEPUT \ put line into block buffer FEND @ IF \ found DOS file end? LEAVE \ yes - exit now THEN LOOP FEND @ \ till DOS file end UNTIL FLUSH CR ." finished. Last screen was " SCR @ 1 - DUP SCR ! . CR ; \ GET-SCRNS transfers DOS file to standard screens 10Nov83RSW : GET-SCRNS CR ." first screen # ? " INPUT DROP CR ." desired DOS screen filename ? " INPUT$ OFILE$ S! OFILE$ DOS->SCRNS ; een # ? " INPUT DROP CR ."